home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASCALL / LIFE / LIFE.PAS next >
Pascal/Delphi Source File  |  1993-02-11  |  5KB  |  189 lines
  1. Program Life;
  2. uses
  3.      crt,graph;
  4. const
  5.      maxmatrix=50;
  6.      death=[0,1,4,5,6,7,8];
  7.      living=[2,3];
  8.      birth=[3];
  9. type
  10.      matrixarray=array[-1..maxmatrix,-1..maxmatrix] of boolean;
  11.  
  12.  
  13. procedure setupgraph;
  14. var
  15.      gd,gm:integer;
  16. begin
  17.      gd:=mcga;
  18.      gm:=mcgahi;
  19.      initgraph(gd,gm,'c:\tp\bgi');
  20.      if graphresult<>grOk then halt;
  21.      settextstyle(smallfont,horizdir,1);
  22. end;
  23.  
  24.  
  25. procedure zeroset(var matrix:matrixarray);
  26. var
  27.      a,b:integer;
  28. begin
  29.      for a:=-1 to maxmatrix do
  30.          for b:=-1 to maxmatrix do
  31.               matrix[a,b]:=false;
  32. end;
  33.  
  34.  
  35. procedure draw(command:byte;  matrix:matrixarray;  x,y:integer);
  36. const
  37.      clearbord=1;
  38.      clearborder=clearbord+clearbord+1;
  39. var
  40.      txh,txw:integer;
  41.  
  42.   procedure field(txh,txw:integer);
  43.   var
  44.        a:integer;
  45.   begin
  46.        setcolor(3);
  47.        for a:=0 to maxmatrix do
  48.        begin
  49.             line(a*txw,0,a*txw,(maxmatrix)*txh);
  50.             line(0,a*txh,(maxmatrix)*txh,a*txw);
  51.        end;
  52.   end;
  53.  
  54.   procedure pieces(txh,txw:integer;  matrix:matrixarray);
  55.   var
  56.        x,y:integer;
  57.   begin
  58.        setcolor(1);
  59.        setfillstyle(solidfill,black);
  60.        for x:=0 to maxmatrix-1 do
  61.             for y:=0 to maxmatrix-1 do
  62.             begin
  63.                  bar(x*txw+1,y*txh+1,(x+1)*txw-1,(y+1)*txh-1);
  64.                  if matrix[x,y] then outtextxy(x*txw+2,y*txh+2,'O');
  65.             end;
  66.   end;
  67.  
  68.   procedure part(txh,txw:integer;  matrix:matrixarray;  x,y:integer);
  69.   var
  70.        a,b:integer;
  71.   begin
  72.        setcolor(1);
  73.        for a:=x-1 to x+1 do
  74.             for b:=y-1 to y+1 do
  75.             begin
  76.                 bar(a*txw+1,b*txh+1,(a+1)*txw-1,(b+1)*txh-1);
  77.                 if matrix[a,b] then outtextxy(a*txw+2,b*txh+2,'O');
  78.             end;
  79.   end;
  80.  
  81.   procedure pointer(txh,txw:integer;  matrix:matrixarray;  x,y:integer);
  82.   begin
  83.        part(txh,txw,matrix,x,y);
  84.        bar(x*txw+1,y*txh+1,(x+1)*txw-1,(y+1)*txh-1);
  85.        setcolor(2);
  86.        outtextxy(x*txw+2,y*txh+2,'X');
  87.   end;
  88.  
  89.  
  90. begin
  91.      txh:=textheight('I')+clearborder;
  92.      txw:=textwidth('H')+clearborder;
  93.      case command of
  94.           1: pieces(txh,txw,matrix);
  95.           2: field(txh,txw);
  96.           3: pointer(txh,txw,matrix,x,y);
  97.           4: part(txh,txw,matrix,x,y);
  98.      end;
  99. end;
  100.  
  101.  
  102. procedure inputmatrix(var matrix:matrixarray;  var continue:boolean;  var x,y:integer);
  103. var
  104.      a:char;
  105. begin
  106.      repeat
  107.           draw(3,matrix,x,y);
  108.           a:=readkey;
  109.           case a of
  110.                '1': if (y<maxmatrix-1) and (x>0) then begin x:=x-1; y:=y+1; end;
  111.                '2': if y<maxmatrix-1 then y:=y+1;
  112.                '3': if (y<maxmatrix-1) and (x<maxmatrix-1) then begin y:=y+1; x:=x+1; end;
  113.                '4': if x>0 then x:=x-1;
  114.                '6': if x<maxmatrix-1 then x:=x+1;
  115.                '7': if (x>0) and (y>0) then begin x:=x-1; y:=y-1; end;
  116.                '8': if y>0 then y:=y-1;
  117.                '9': if (y>0) and (x<maxmatrix-1) then begin x:=x+1; y:=y-1 end;
  118.                ' ': matrix[x,y]:=not matrix[x,y];
  119.                else begin  end;
  120.           end;
  121.      until (upcase(a)='S') or (ord(a)=27);
  122.      if upcase(a)='S' then continue:=true else continue:=false;
  123. end;
  124.  
  125.  
  126. procedure matrixgeneration(var matrix:matrixarray);
  127. var
  128.      x,y:integer;
  129.      duh:matrixarray;
  130.  
  131.  function lifeanddeath(m:matrixarray;  x,y:integer):boolean;
  132.  var
  133.       a,b,n:integer;
  134.  begin
  135.       n:=0;
  136.       a:=x-1;
  137.       for b:=y-1 to y+1 do
  138.             if m[a,b] then n:=n+1;
  139.       a:=x+1;
  140.       for b:=y-1 to y+1 do
  141.             if m[a,b] then n:=n+1;
  142.       if m[x,y+1] then n:=n+1;
  143.       if m[x,y-1] then n:=n+1;
  144.       case m[x,y] of
  145.            true: lifeanddeath:=(n in living);
  146.            false: lifeanddeath:=(n in birth);
  147.       end;
  148.  end;
  149.  
  150. begin
  151.      zeroset(duh);
  152.      for x:=0 to maxmatrix-1 do
  153.           for y:=0 to maxmatrix-1 do
  154.                duh[x,y]:=lifeanddeath(matrix,x,y);
  155.                draw(4,duh,x,y);
  156.      matrix:=duh;
  157. end;
  158.  
  159.  
  160. procedure lively;
  161. var
  162.      matrix:matrixarray;
  163.      x,y:integer;
  164.      continue:boolean;
  165. begin
  166.      zeroset(matrix);
  167.      x:=0;     y:=0;
  168.      continue:=true;
  169. {     draw(2,matrix,x,y);}
  170.      draw(1,matrix,x,y);
  171.      inputmatrix(matrix,continue,x,y);
  172.      while continue do
  173.      begin
  174.           while not keypressed do
  175.           begin
  176.                matrixgeneration(matrix);
  177.                draw(1,matrix,x,y);
  178.           end;
  179.           inputmatrix(matrix,continue,x,y);
  180.      end;
  181. end;
  182.  
  183.  
  184. begin
  185.      setupgraph;
  186.      lively;
  187.      closegraph;
  188.      restorecrtmode;
  189. end.